Shareware Grab Bag/Shareware Grab Bag.iso/005/tsrcom16.arc/RELEASE.PAS

Pascal/Delphi Source File | 1986-03-20 | 14.2 KB | 419 lines

{**************************************************************************
*   Releases memory above the last MARK call made.                        *
*   Copyright (c) 1986 Kim Kokkonen, TurboPower Software.                 *
*   Released to the public domain for personal, non-commercial use only.  *
***************************************************************************
*   Version 1.0 2/8/86                                                    *
*     original public release.                                            *
*     (thanks to Neil Rubenking for an outline of the method used)        *
*   Version 1.1 2/11/86                                                   *
*     fixed problem with processes which deallocate their environment.    *
*   Version 1.2 2/13/86                                                   *
*     fixed another problem with processes which deallocate environment.  *
*   Version 1.3 2/15/86                                                   *
*     added support for "named" marks.                                    *
*   Version 1.4 2/23/86                                                   *
*     added support for releasing programs which use Expanded Memory.     *
*   Version 1.5 2/28/86                                                   *
*     added more bulletproof method of finding first allocation block.    *
*   Version 1.6 3/20/86                                                   *
*     restore all FF interrupts.                                          *
*     restore the termination address to the local process.               *
*     reduce number of EMS blocks to 32.                                  *
*     fix bug in number of EMS handles in EMS release step.               *
*     restore a mysterious address in the PSP which allows RELEASE of a   *
*       COMMAND shell.                                                    *
***************************************************************************
*   telephone: [phone], CompuServe: 72457,2131.                      *
*   requires Turbo version 3 to compile.                                  *
*   Compile with mAx dynamic memory = FFFF.                               *
***************************************************************************}

{$P128}

PROGRAM ReleaseTSR;
  {-release system memory above the last mark call}
  {-release expanded memory blocks allocated since the last mark call}

CONST
  Version = '1.6';
  MaxBlocks = 128;            {max number of DOS allocation blocks supported}
  MaxHandles = 32;            {max number of EMS allocation blocks supported}
  EMSinterrupt = $67;         {the vector used by the expanded memory manager}

  markID = 'MARK PARAMETER BLOCK FOLLOWS'; {marking string for TSR MARK}

  {offsets into resident copy of MARK.COM for data storage}
  markOffset = $103;          {where markID is found in TSR}
  vectorOffset = $120;        {where vector table is stored}
  EMScntOffset = $520;        {where count of EMS active pages is stored}
  EMSmapOffset = $522;        {where the page map is stored}

TYPE
  registers =
  RECORD
    CASE Integer OF
      1 : (ax, bx, cx, dx, bp, si, di, ds, es, flags : Integer);
      2 : (al, ah, bl, bh, cl, ch, dl, dh : Byte);
  END;

  HandlePageRecord =
  RECORD
    handle : Integer;
    numpages : Integer;
  END;

  PageArray = ARRAY[1..MaxHandles] OF HandlePageRecord;
  PageArrayPtr = ^PageArray;

  Block =
  RECORD                      {store info about each memory block}
    mcb : Integer;
    psp : Integer;
    releaseIt : Boolean;
  END;

  BlockType = 0..MaxBlocks;
  BlockArray = ARRAY[BlockType] OF Block;
  AllStrings = STRING[255];
  HexString = STRING[4];

VAR
  Blocks : BlockArray;
  bottomBlock, blockNum : BlockType;
  markName : AllStrings;
  Regs : registers;
  StoredHandles, EMShandles : Integer;
  Map, StoredMap : PageArrayPtr;

  PROCEDURE FindTheBlocks;
    {-scan memory for the allocated memory blocks}
  CONST
    MidBlockID = $4D;         {byte DOS uses to identify part of MCB chain}
    EndBlockID = $5A;         {byte DOS uses to identify last block of MCB chain}
  VAR
    mcbSeg : Integer;         {segment address of current MCB}
    nextSeg : Integer;        {computed segment address for the next MCB}
    gotFirst : Boolean;       {true after first MCB is found}
    gotLast : Boolean;        {true after last MCB is found}
    idbyte : Byte;            {byte that DOS uses to identify an MCB}

    FUNCTION GetStartMCB : Integer;
      {-return the first MCB segment}
    BEGIN
      Regs.ah := $52;
      MsDos(Regs);
      GetStartMCB := MemW[Regs.es:(Regs.bx-2)];
    END {getstartmcb} ;

    PROCEDURE StoreTheBlock(VAR mcbSeg, nextSeg : Integer;
                            VAR gotFirst, gotLast : Boolean);
      {-store information regarding the memory block}
    VAR
      nextID : Byte;
      pspAdd : Integer;       {segment address of the current PSP}
      mcbLen : Integer;       {size of the current memory block in paragraphs}

    BEGIN

      mcbLen := MemW[mcbSeg:3]; {size of the MCB in paragraphs}
      nextSeg := Succ(mcbSeg+mcbLen); {where the next MCB should be}
      pspAdd := MemW[mcbSeg:1]; {address of program segment prefix for MCB}
      nextID := Mem[nextSeg:0];

      IF gotLast OR (nextID = EndBlockID) OR (nextID = MidBlockID) THEN BEGIN
        blockNum := Succ(blockNum);
        gotFirst := True;
        WITH Blocks[blockNum] DO BEGIN
          mcb := mcbSeg;
          psp := pspAdd;
        END;
      END;

    END {storetheblock} ;

  BEGIN

    {initialize}
    mcbSeg := GetStartMCB;
    gotFirst := False;
    gotLast := False;
    blockNum := 0;

    {scan all memory until the last block is found}
    REPEAT
      idbyte := Mem[mcbSeg:0];
      IF idbyte = MidBlockID THEN BEGIN
        StoreTheBlock(mcbSeg, nextSeg, gotFirst, gotLast);
        IF gotFirst THEN mcbSeg := nextSeg ELSE mcbSeg := Succ(mcbSeg);
      END ELSE IF gotFirst AND (idbyte = EndBlockID) THEN BEGIN
        gotLast := True;
        StoreTheBlock(mcbSeg, nextSeg, gotFirst, gotLast);
      END ELSE BEGIN
        {start block was invalid}
        WriteLn('corrupted allocation chain or program error');
        Halt(1);
      END;
    UNTIL gotLast;

  END {findtheblocks} ;

  FUNCTION FindMark(idString, markName : AllStrings;
                    idOffset : Integer) : Integer;
    {-find the last memory block matching idstring at offset idoffset}
  VAR
    b : BlockType;
    FoundIt : Boolean;

    FUNCTION MatchString(segment : Integer;
                         idString, markName : AllStrings;
                         idOffset : Integer) : Boolean;
      {-return true if idstring is found at segment:idoffset}
    VAR
      tString : AllStrings;
      len : Byte;
      FoundIt : Boolean;

      FUNCTION StUpcase(s : AllStrings) : AllStrings;
        {-return the uppercase string}
      VAR
        i : Byte;
      BEGIN
        FOR i := 1 TO Length(s) DO s[i] := UpCase(s[i]);
        StUpcase := s;
      END {stupcase} ;

    BEGIN
      len := Length(idString);
      tString[0] := Chr(len);
      Move(Mem[segment:idOffset], tString[1], len);
      FoundIt := (tString = idString);
      IF FoundIt AND (markName <> '') THEN BEGIN
        {check the mark name stored in the PSP of the mark block}
        Move(Mem[segment:$80], tString[0], 128);
        WHILE (tString[1] = ' ') OR (tString[1] = ^I) DO Delete(tString, 1, 1);
        FoundIt := (StUpcase(tString) = StUpcase(markName));
      END;
      MatchString := FoundIt;
    END {matchstring} ;

  BEGIN
    {scan from the last block-1 down to find the last MARK TSR}
    b := Pred(blockNum);
    REPEAT
      FoundIt := MatchString(Blocks[b].psp, idString, markName, idOffset);
      IF NOT(FoundIt) THEN b := Pred(b);
    UNTIL (b < 1) OR FoundIt;
    IF NOT(FoundIt) THEN BEGIN
      WriteLn('No matching memory marker found. Mark memory by running MARK.COM.');
      Halt(1);
    END;
    FindMark := b;
  END {findmark} ;

  PROCEDURE CopyVectors(bottomBlock : BlockType; vectorOffset : Integer);
    {-put interrupt vectors back into table}
  BEGIN
    {interrupts off}
    INLINE($FA);
    {replace vectors}
    Move(Mem[Blocks[bottomBlock].psp:vectorOffset], Mem[0:0], 1024);
    {move the old termination/break/error addresses into this program}
    Move(Mem[0:$88], Mem[CSeg:$0A], 12);
    {move into a mysterious address used by the DOS EXIT command to remove a shell}
    Move(Mem[CSeg:$0C], Mem[CSeg:$16], 2);
    {interrupts on}
    INLINE($FB);
  END {copyvectors} ;

  FUNCTION Hex(i : Integer) : HexString;
    {-return hex representation of integer}
  CONST
    hc : ARRAY[0..15] OF Char = '0123456789ABCDEF';
  VAR
    l, h : Byte;
  BEGIN
    l := Lo(i); h := Hi(i);
    Hex := hc[h SHR 4]+hc[h AND $F]+hc[l SHR 4]+hc[l AND $F];
  END {hex} ;

  PROCEDURE MarkBlocks(bottomBlock : BlockType);
    {-mark those blocks to be released}
    {complicated by TSRs which deallocate their environment}
  VAR
    b : BlockType;
    BottomPSP : Real;

    FUNCTION Cardinal(i : Integer) : Real;
      {-return a real 0..65535}
    BEGIN
      Cardinal := 256.0*Hi(i)+Lo(i);
    END {cardinal} ;

  BEGIN
    BottomPSP := Cardinal(Blocks[bottomBlock].psp);
    FOR b := 1 TO blockNum DO WITH Blocks[b] DO BEGIN
      releaseIt := False;
      IF (b < Pred(bottomBlock)) AND (Cardinal(psp) >= BottomPSP) THEN
        WriteLn('WARNING: trapped memory block at PSP ', Hex(psp), ' will not be released')
      ELSE IF (Cardinal(psp) >= BottomPSP) AND (psp <> CSeg) THEN
        releaseIt := True;
    END;
  END {markblocks} ;

  PROCEDURE ReleaseMem;
    {release DOS memory marked for release}
  VAR
    b : BlockType;
  BEGIN
    WITH Regs DO
      FOR b := 1 TO blockNum DO WITH Blocks[b] DO
        IF releaseIt THEN BEGIN
          ah := $49;
          {the block is always 1 paragraph above the MCB}
          es := Succ(mcb);
          MsDos(Regs);
          IF Odd(flags) THEN BEGIN
            WriteLn('Could not release block at segment ', Hex(es));
            WriteLn('Memory is now a mess... Please reboot');
            Halt(1);
          END;
        END;
  END {releasemem} ;

  FUNCTION EMSpresent : Boolean;
    {-return true if EMS memory manager is present}
  VAR
    f : FILE;
  BEGIN
    {"file handle" defined by the expanded memory manager at installation}
    Assign(f, 'EMMXXXX0');
    {$I-} Reset(f) {$I+} ;
    EMSpresent := (IOResult = 0);
    Close(f);
  END {EMSpresent} ;

  FUNCTION EMShandlesActive : Integer;
    {-return the number of active EMS handles}
  BEGIN
    Regs.ah := $4B;
    Intr(EMSinterrupt, Regs);
    IF Regs.ah <> 0 THEN BEGIN
      WriteLn('EMS device not responding');
      EMShandlesActive := 0;
      Exit;
    END;
    EMShandlesActive := Regs.bx;
  END {EMShandlesActive} ;

  FUNCTION GetHandles(bottomBlock : BlockType; EMScntOffset : Integer) : Integer;
    {-return the number of handles stored by mark}
  VAR
    gh : Integer;
  BEGIN
    Move(Mem[Blocks[bottomBlock].psp:EMScntOffset], gh, 2);
    GetHandles := gh;
  END {gethandles} ;

  PROCEDURE EMSpageMap(VAR PageMap : PageArray);
    {-return an array of the allocated memory blocks}
  BEGIN
    Regs.ah := $4D;
    Regs.es := Seg(PageMap);
    Regs.di := Ofs(PageMap);
    Regs.bx := 0;
    Intr(EMSinterrupt, Regs);
    IF Regs.ah <> 0 THEN
      WriteLn('EMS device not responding');
  END {EMSpageMap} ;

  PROCEDURE ReleaseEMSblocks(VAR oldmap, newmap : PageArray);
    {-release those EMS blocks allocated since MARK was installed}
  VAR
    o, n, nhandle : Integer;

    PROCEDURE EMSdeallocate(EMShandle : Integer);
      {-release the allocated expanded memory}
    BEGIN
      Regs.ah := $45;
      Regs.dx := EMShandle;
      Intr(EMSinterrupt, Regs);
      IF Regs.ah <> 0 THEN BEGIN
        WriteLn('Program error or EMS device not responding');
        WriteLn('EMS memory is now a mess... Please reboot');
        Halt;
      END;
    END;                      {EMSdeallocate}

  BEGIN
    FOR n := 1 TO EMShandles DO BEGIN
      {scan all current handles}
      nhandle := newmap[n].handle;
      IF StoredHandles > 0 THEN BEGIN
        {see if current handle matches one stored by MARK}
        o := 1;
        WHILE (oldmap[o].handle <> nhandle) AND (o <= StoredHandles) DO
          o := Succ(o);
        {if not, deallocate the current handle}
        IF (o > StoredHandles) THEN
          EMSdeallocate(nhandle);
      END ELSE
        {no handles stored by MARK, deallocate all current handles}
        EMSdeallocate(nhandle);
    END;
  END {releaseEMSblocks} ;

BEGIN

  WriteLn;

  {see if a particular mark is named}
  IF ParamCount > 0 THEN
    markName := ParamStr(1)
  ELSE
    markName := '';

  {get all allocated memory blocks in normal memory}
  FindTheBlocks;

  {find the last one marked with the MARK idstring, and MarkName if specified}
  bottomBlock := FindMark(markID, markName, markOffset);

  {copy the vector table from the MARK resident}
  CopyVectors(bottomBlock, vectorOffset);

  {mark those blocks to be released}
  MarkBlocks(bottomBlock);

  {release normal memory marked for release}
  ReleaseMem;

  {see if expanded memory card is installed}
  IF EMSpresent THEN BEGIN
    {see how many EMS handles are currently active}
    EMShandles := EMShandlesActive;
    IF EMShandles > MaxHandles THEN
      WriteLn('EMS process count exceeds capacity of RELEASE')
    ELSE IF EMShandles <> 0 THEN BEGIN
      {see how many handles were active when MARK was installed}
      StoredHandles := GetHandles(bottomBlock, EMScntOffset);
      {get the existing EMS page map}
      GetMem(Map, 4*EMShandles);
      EMSpageMap(Map^);
      {get the stored page map}
      StoredMap := Ptr(Blocks[bottomBlock].psp, EMSmapOffset);
      {compare the two maps and deallocate those not in the stored map}
      ReleaseEMSblocks(StoredMap^, Map^);
    END;
  END;

  {DOS will release this program's memory when it exits}
  {write success message}
  Write('RELEASE ', Version, ' - Memory released above last MARK ');
  IF markName <> '' THEN
    WriteLn('(', markName, ')')
  ELSE
    WriteLn;

END.